home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / think-c-interface.sea / Think C interface / example.c next >
Encoding:
C/C++ Source or Header  |  1991-12-05  |  4.0 KB  |  193 lines  |  [TEXT/KAHL]
  1. #include <lisp.h>
  2. #include <loader.h>
  3.  
  4. /*
  5.     When you do a Set Project Type…, you should
  6.     fill in the dialog fields in the following way:
  7.     
  8.     Project Type  -> Code Resource (the radio button)
  9.     File Type     -> As you wish
  10.     Creator       -> As you wish
  11.     Multi-Segment -> As you wish
  12.     Name          -> The name of your module (as expected by DEFCMODULE)
  13.     Type          -> TCCD
  14.     Id            -> As you wish (63 or lower if multi-segmented)
  15.     Attrs         -> 10 (only check the Locked menu item)
  16.     Custom Header -> Unchecked
  17. */
  18.  
  19. /*
  20.     If one of your function wants to return a value,
  21.     it has to be of type long. That's because ThinkC
  22.     returns result values in D0 and MCL reads a D0
  23.     returned value as a long.
  24.     
  25.     If your function wants to return a pointer, you
  26.     can use the RETURN_A0 macro defined in <lisp.h>.
  27. */
  28.  
  29. /*
  30.     When MCL passes a Lisp object, it passes a pointer to it.
  31.     That's why you need to use the GET macro to get to the actual Lisp object.
  32.     
  33.     MCL's fixnums are shifted by 3 bits (we say they are boxed).
  34.     That's why you need to use to UNBOX macro to get the actual value.
  35.     
  36.     When you return a value (in D0), you don't need to BOX it first, as MCL
  37.     will do it for you when your FF-CALL exits.
  38. */
  39.  
  40. long testFixnum (long ptr)
  41. {
  42.     return(UNBOX(GET(ptr)) + 1);
  43. }
  44.  
  45. long testCharacter (long ptr)
  46. {
  47.     switch (CHARACTER(GET(ptr))) {
  48.         case 'a': return 1; break;
  49.         case 'b': return 2; break;
  50.         case 'c': return 3; break;
  51.         default:  return 4;
  52.     }
  53. }
  54.  
  55. void testList (long ptr)
  56. {
  57.     long list = GET(ptr);
  58.  
  59.     CAR(list) += 8;
  60.     CDR(list) = CDR(CDR(list));
  61. }
  62.  
  63. struct foo {
  64.     long a, b, c;
  65. };
  66.  
  67. void testStruct (long ptr)
  68. {
  69.     struct foo *s = STRUCTURE(GET(ptr),foo);
  70.     
  71.     /*
  72.         As we are playing in MCL's back, we need to BOX our integers.
  73.     */
  74.  
  75.     s->a += BOX(1);
  76.     s->b += BOX(2);
  77.     s->c += BOX(3);
  78. }
  79.  
  80. /*
  81.     Passing multi-dimentionnal arrays to C would be
  82.     very awkward because MCL implements multi-dimentionnal
  83.     arrays as displaced arrays.
  84. */
  85.  
  86. void testVector (long ptr)
  87. {
  88.     int i;
  89.     long *vec = VECTOR(GET(ptr));
  90.  
  91.     for(i=0; i<5; i++) {
  92.         vec[i] += BOX(i);
  93.     }
  94. }
  95.  
  96. /*
  97.     A string is simply a vector of characters,
  98.     each one taking one byte of memory.
  99. */
  100.  
  101. void testString (long ptr)
  102. {
  103.     int i;
  104.     char *str = STRING(GET(ptr));
  105.     
  106.     for(i=0; i<STRING_SIZE(GET(ptr)); i++) {
  107.         if (str[i] == 'a')
  108.             str[i] = 'A';
  109.     }
  110. }
  111.  
  112. void testShortDouble (long ptr)
  113. {
  114.     short double *x = FLOAT(GET(ptr));
  115.     *x = *x + 1.2;
  116. }
  117.  
  118. void testDouble (double *x)
  119. {
  120.     *x = *x + 1.2;
  121. }
  122.  
  123. /*
  124.     If you allocate your structures 'a la' C, then your C code
  125.     becomes very nice and efficient (but see the THOUGHTS file for drawbacks).
  126. */
  127.  
  128. struct myStruct {
  129.     long a, b, c;
  130. };
  131.  
  132. void testCStructures (struct myStruct *ptr)
  133. {
  134.     ptr->c += ptr->a + ptr->b;
  135. }
  136.  
  137. void testA0 (char *ptr)
  138. {
  139.     RETURN_A0(ptr+1);
  140. }
  141.  
  142. long testCallback (long ptr, void (*lispfn) ())
  143. {
  144.     (*lispfn) ();
  145.     return(UNBOX(CAR(GET(ptr))));
  146. }
  147.  
  148. long    myLong   = 11;
  149. double    myDouble = 0.23;
  150.  
  151. long testGlobals ()
  152. {
  153.     return( myLong * myLong );
  154. }
  155.  
  156. extern testMultiSegment();
  157.  
  158. void testTraps()
  159. {
  160.     RETURN_A0(NewPtr(12));
  161. }
  162.  
  163. /*
  164.     If the names match, the EXPORT macro returns the
  165.     address of the function    in the A0 register.
  166.  
  167.     If no EXPORT is successfull then the LOADER_ERROR
  168.     macro returns a NIL pointer in A0.
  169. */
  170.  
  171. main (unsigned char name[])
  172. {
  173.     EXPORT(name, myLong,           "\pMY-LONG");
  174.     EXPORT(name, myDouble,         "\pMY-DOUBLE");
  175.     
  176.     EXPORT(name, testFixnum,       "\pTEST-FIXNUM");
  177.     EXPORT(name, testCharacter,    "\pTEST-CHARACTER");
  178.     EXPORT(name, testList,         "\pTEST-LIST");
  179.     EXPORT(name, testStruct,       "\pTEST-STRUCT");
  180.     EXPORT(name, testVector,       "\pTEST-VECTOR");
  181.     EXPORT(name, testString,       "\pTEST-STRING");
  182.     EXPORT(name, testShortDouble,  "\pTEST-SHORT-DOUBLE");
  183.     EXPORT(name, testDouble,       "\pTEST-DOUBLE");
  184.     EXPORT(name, testCStructures,  "\pTEST-C-STRUCTURES");
  185.     EXPORT(name, testA0,           "\pTEST-A0");
  186.     EXPORT(name, testCallback,     "\pTEST-CALLBACK");
  187.     EXPORT(name, testGlobals,      "\pTEST-GLOBALS");
  188.     EXPORT(name, testMultiSegment, "\pTEST-MULTI-SEGMENT");
  189.     EXPORT(name, testTraps,        "\pTEST-TRAPS");
  190.  
  191.     LOADER_ERROR();
  192. }
  193.